;; =============================================================================
;; another approach
;; =============================================================================

;;(load "bindings.lisp")

(defstruct c-codegen-context
  (indent nil :type fixnum)
  (first-block-expression nil :type boolean)
  (types nil :type hash-table)
  (functions nil :type hash-table)
  (keywords nil :type hash-table))

(defparameter *default-indent* 4)


(defmacro gen-c-expr-expansion (func-id func-body &rest mapping-list)
  `(cond
    ,@(loop for i in mapping-list collect
	    `((eq ',(car i) ,func-id)
	      (static-bindings ,func-body ,(cadr i)
	       ;; form
	       (prn-hint context ',(car i) 'begin)
	       ,@(cddr i)
	       (prn-hint context ',(car i) 'end)
	       )))
    (t (error "unexpected func-id"))
    ))

(defun prn (context &rest args)
  (check-type context c-codegen-context)
  (dolist (arg args)
    (check-type arg (or standard-char string))
    (format t "~a" arg)))

(defun prn-hint (context scope-id location)
  (cond
    ;; block beginning
    ((and (or (eq scope-id 'block))
	  (eq location 'begin))
     (prn context #\Newline)
     (incf (c-codegen-context-indent context) *default-indent*)
     (setf (c-codegen-context-first-block-expression context) t))

    ;; block end
    ((and (or (eq scope-id 'block))
	  (eq location 'end))
     (prn context #\Newline)
     (decf (c-codegen-context-indent context) *default-indent*))
    
    ;; scope end
    ((and (or (eq scope-id 'include-local) (eq scope-id 'include-global))
	  (eq location 'end))
     (prn context #\Newline))

    ;; block expression begin
    ((and (eq scope-id 'block-expression) (eq location 'begin))
     (if (c-codegen-context-first-block-expression context) (prn context #\Newline))
     ;; print indentation
     (loop for i from 1 to (c-codegen-context-indent context) do (prn context " "))
     (setf (c-codegen-context-first-block-expression context) nil))

    ;; block expression end
    ((and (eq scope-id 'block-expression) (eq location 'end))
     (prn context #\Newline))
    ))

(defun printable-c-type-name (context type-sym)
  (let ((v-type (gethash type-sym (c-codegen-context-types context))))
    (unless v-type (error "such a type has not been registered"))
    ;; return v-type
    v-type))

(defun printable-c-func-name (context func-name-sym)
  ;; FIXME: more correct transformation?
  (format nil "~a" func-name-sym))

(defun printable-c-arg-name (context func-name-sym)
  ;; FIXME: more correct transformation?
  (format nil "~a" func-name-sym))

;; =============================================================================
;; processes block expression
(defun process-c-expr-block-expression (context expr)
  (prn-hint context 'block-expression 'begin)
  (prn context "// block expression: " (format nil "~a" expr))
  (prn-hint context 'block-expression 'end))

;; =============================================================================
;; processes block
(defun process-c-expr-block (context expr)
  ;; FIXME: prn-hint exposed here
  (prn-hint context 'block 'begin)
  (prn context "{")
  (dolist (block-expr expr)
    (process-c-expr-block-expression context block-expr))
  (prn context "}")
  ;; FIXME: prn-hint exposed here
  (prn-hint context 'block 'end))

;; =============================================================================
;; processes arguments list
(defun process-c-expr-func-arglist (context expr)
  ;; FIXME: prn-hint exposed here
  (prn-hint context 'func-arglist 'begin)
  
  (prn context "(")
  (let ((first-arg t))
    (dolist (func-arg expr)
      (if first-arg
	  (setf first-arg nil)
	  (prn context ", "))

      (prn-hint context 'arg 'begin)

      (prn context
	   (printable-c-type-name context (car func-arg))
	   " "
	   (printable-c-arg-name context (cadr func-arg)))
      
      (prn-hint context 'arg 'end)))
  (prn context ")")

  ;; FIXME: prn-hint exposed here
  (prn-hint context 'func-arglist 'end))

(defun process-c-expr-toplev (context expr)
  (let ((func-id (car expr)) (func-body (cdr expr)))
    ;; cond expansion that processes the given expression
    (gen-c-expr-expansion
     func-id				; bound function id
     func-body				; bound function body

     ;; functions

     ;; #include "header"
     (include-local (name)
		    (prn context "#include \"" name "\""))

     ;; #include <header>
     (include-global (name)
		     (prn context "#include <" name ">"))

     ;; function declaration, e.g. int foo(int arg) { return arg+5; }
     (func (type-and-name arglist &rest body)
	   (prn context
		;; type name
		(printable-c-type-name context (car type-and-name))
		" "
		(printable-c-func-name context (cadr type-and-name))
		)

	   ;; function's arguments list
	   (process-c-expr-func-arglist context arglist)

	   ;; if this is a forward decl - prn ; otherwise prn all the block
	   (if (null body)
	       (prn ";")
	       (process-c-expr-block context body)))

     )))

;; =============================================================================
;; associates symbol w/string in the given table
(defun assoc-strs (hashtable arglist)
  (check-type hashtable hash-table)
  (dolist (arg arglist)
    (let (src assoc)
      (cond
	((consp arg)
	 (setf src (car arg))
	 (setf assoc (cadr arg))
	 (check-type src symbol)
	 (check-type assoc string))
	((symbolp arg)
	 (setf src arg)
	 (setf assoc (format nil "~a" src)))
	(t (error "invalid arg-assoc construction")))
      (setf (gethash src hashtable) assoc))))


;; =============================================================================
;; test
(defun make-test-c-codegen-context ()
  (let ((types (make-hash-table))
	(functions (make-hash-table))
	(keywords (make-hash-table)))
    ;; fill types
    (assoc-strs types
		'(int
		  (const-char-pp "const char **")))

    ;; fill functions
    (assoc-strs functions
		'(fputs getchar iosfwd))

    ;; fill keywords
    (setf (gethash 'return keywords) (lambda (context expr)
				       (format t "return ")
				       (emit-expr context (car expr))
				       (format t ";~%")))
    
    ;; create context
    (make-c-codegen-context
     :indent 0
     :types types
     :functions functions
     :keywords keywords)))

(defun tst33 ()

  ;; test 1
  (process-c-expr-toplev
   (make-test-c-codegen-context)
   '(func (int main) ((int argc) (const-char-pp argv)) (return 0))
   ;;'(include-local "asd")
   )

  (process-c-expr-toplev
   (make-test-c-codegen-context)
   '(func (int main) ((int argc) (const-char-pp argv)) (fprintf stderr "argc = %d" argc) (return 0)))
  )

